home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
FishMarket 1.0
/
FishMarket v1.0.iso
/
fishies
/
376-400
/
disk_386
/
xlispstat
/
src1.lzh
/
XLisp
/
xlprin.c
< prev
next >
Wrap
C/C++ Source or Header
|
1990-10-03
|
10KB
|
382 lines
/* xlprint - xlisp print routine */
/* Copyright (c) 1989, by David Michael Betz. */
/* You may give out copies of this software; for conditions see the file */
/* COPYING included with this distribution. */
#include <string.h>
#include "xlisp.h"
#include "osdef.h"
#ifdef ANSI
#include "xlproto.h"
#include "xlsproto.h"
#else
#include "xlfun.h"
#include "xlsfun.h"
#endif ANSI
#include "xlvar.h"
/* forward declarations */
#ifdef ANSI
void putoct(LVAL,int),putchcode(LVAL,int,int),putflonum(LVAL,FLOTYPE),
putfixnum(LVAL,FIXTYPE),putclosure(LVAL,LVAL),putsubr(LVAL,char *,LVAL),
putatm(LVAL,char *,LVAL),putqstring(LVAL,LVAL),putstring(LVAL,LVAL),
putsymbol(LVAL,char *,int);
#else
void putoct(),putchcode(),putflonum(),
putfixnum(),putclosure(),putsubr(),
putatm(),putqstring(),putstring(),
putsymbol();
#endif ANSI
/* xlprint - print an xlisp value */
void xlprint(fptr,vptr,flag)
LVAL fptr,vptr; int flag;
{
LVAL nptr,next;
int n,i;
/* print nil */
if (vptr == NIL) {
putsymbol(fptr,"NIL",flag);
return;
}
#ifndef XLISP_ONLY
/*************************************************************************/
/* Lines below added to allow for common lisp arrays */
/* Luke Tierney, March 1, 1988 */
/*************************************************************************/
if (displacedarrayp(vptr)) {
putarray(fptr, vptr, flag);
return;
}
/*************************************************************************/
/* Lines above added to allow for common lisp arrays */
/* Luke Tierney, March 1, 1988 */
/*************************************************************************/
#endif /* XLISP_ONLY */
/* check value type */
switch (ntype(vptr)) {
case SUBR:
putsubr(fptr,"Subr",vptr);
break;
case FSUBR:
putsubr(fptr,"FSubr",vptr);
break;
case CONS:
xlputc(fptr,'(');
for (nptr = vptr; nptr != NIL; nptr = next) {
xlprint(fptr,car(nptr),flag);
if (next = cdr(nptr))
if (consp(next))
xlputc(fptr,' ');
else {
xlputstr(fptr," . ");
xlprint(fptr,next,flag);
break;
}
}
xlputc(fptr,')');
break;
case SYMBOL:
putsymbol(fptr,getstring(getpname(vptr)),flag);
break;
case FIXNUM:
putfixnum(fptr,getfixnum(vptr));
break;
case FLONUM:
putflonum(fptr,getflonum(vptr));
break;
case CHAR:
putchcode(fptr,getchcode(vptr),flag);
break;
case STRING:
if (flag)
putqstring(fptr,vptr);
else
putstring(fptr,vptr);
break;
case STREAM:
putatm(fptr,"File-Stream",vptr);
break;
case USTREAM:
putatm(fptr,"Unnamed-Stream",vptr);
break;
case OBJECT:
#ifndef XLISP_ONLY
if (mobject_p(vptr)) { print_mobject(vptr, fptr); break; } /* L. Tierney */
#else
putatm(fptr,"Object",vptr);
break;
#endif /* XLISP_ONLY */
case VECTOR:
xlputc(fptr,'#'); xlputc(fptr,'(');
for (i = 0, n = getsize(vptr) - 1; i <= n; ++i) {
xlprint(fptr,getelement(vptr,i),flag);
if (i != n) xlputc(fptr,' ');
}
xlputc(fptr,')');
break;
case STRUCT:
xlprstruct(fptr,vptr,flag);
break;
case CLOSURE:
putclosure(fptr,vptr);
break;
case COMPLEX: /* L. Tierney */
xlputc(fptr, '#');
xlputc(fptr, (getvalue(s_printcase) == k_downcase) ? 'c' : 'C');
xlputc(fptr, '(');
xlprint(fptr, getelement(vptr, 0), flag);
xlputc(fptr,' ');
xlprint(fptr, getelement(vptr, 1), flag);
xlputc(fptr, ')');
break;
case ALLOCATED_DATA: /* L. Tierney */
putatm(fptr,"Data",vptr);
break;
case FREE:
putatm(fptr,"Free",vptr);
break;
default:
putatm(fptr,"Foo",vptr);
break;
}
}
/* xlterpri - terminate the current print line */
void xlterpri(fptr)
LVAL fptr;
{
xlputc(fptr,'\n');
}
/* xlputstr - output a string */
void xlputstr(fptr,str)
LVAL fptr; char *str;
{
while (*str)
xlputc(fptr,*str++);
}
/* putsymbol - output a symbol */
LOCAL void putsymbol(fptr,str,escflag)
LVAL fptr; char *str; int escflag;
{
int downcase,ch;
LVAL type;
char *p;
/* check for printing without escapes */
if (!escflag) {
xlputstr(fptr,str);
return;
}
/* check to see if symbol needs escape characters */
if (tentry(*str) == k_const) {
for (p = str; *p; ++p)
if (islower(*p)
|| ((type = tentry(*p)) != k_const
&& (!consp(type) || car(type) != k_nmacro))) {
xlputc(fptr,'|');
while (*str) {
if (*str == '\\' || *str == '|')
xlputc(fptr,'\\');
xlputc(fptr,*str++);
}
xlputc(fptr,'|');
return;
}
}
/* get the case translation flag */
downcase = (getvalue(s_printcase) == k_downcase);
/* check for the first character being '#' */
if (*str == '#' || *str == '.' || isnumber(str,NULL))
xlputc(fptr,'\\');
/* output each character */
while ((ch = *str++) != '\0') {
/* don't escape colon until we add support for packages */
if (ch == '\\' || ch == '|' /* || ch == ':' */)
xlputc(fptr,'\\');
xlputc(fptr,(downcase && isupper(ch) ? tolower(ch) : ch));
}
}
/* putstring - output a string */
LOCAL void putstring(fptr,str)
LVAL fptr,str;
{
unsigned char *p;
int ch;
/* output each character */
for (p = getstring(str); (ch = *p) != '\0'; ++p)
xlputc(fptr,ch);
}
/* putqstring - output a quoted string */
LOCAL void putqstring(fptr,str)
LVAL fptr,str;
{
unsigned char *p;
int ch;
/* get the string pointer */
p = getstring(str);
/* output the initial quote */
xlputc(fptr,'"');
/* output each character in the string */
for (p = getstring(str); (ch = *p) != '\0'; ++p)
/* check for a control character */
/* added double quote - Luke Tierney */
/* removed newline - Luke Tierney */
if (ch != '\n' && (ch < 040 || ch == '\\' || ch > 0176 || ch == '"')) {
xlputc(fptr,'\\');
switch (ch) {
case '"': /* added double quote - Luke Tierney */
xlputc(fptr,'"');
break;
case '\011':
xlputc(fptr,'t');
break;
case '\012':
xlputc(fptr,'n');
break;
case '\014':
xlputc(fptr,'f');
break;
case '\015':
xlputc(fptr,'r');
break;
case '\\':
xlputc(fptr,'\\');
break;
default:
putoct(fptr,ch);
break;
}
}
/* output a normal character */
else
xlputc(fptr,ch);
/* output the terminating quote */
xlputc(fptr,'"');
}
/* putatm - output an atom */
LOCAL void putatm(fptr,tag,val)
LVAL fptr; char *tag; LVAL val;
{
sprintf(buf,"#<%s: #",tag); xlputstr(fptr,buf);
sprintf(buf,AFMT,val); xlputstr(fptr,buf);
xlputc(fptr,'>');
}
/* putsubr - output a subr/fsubr *//* modified for nil names - L. Tierney */
LOCAL void putsubr(fptr,tag,val)
LVAL fptr; char *tag; LVAL val;
{
char *name = funtab[getoffset(val)].fd_name;
if (! name) name = "(internal)";
sprintf(buf,"#<%s-%s: #",tag,name);
xlputstr(fptr,buf);
sprintf(buf,AFMT,val); xlputstr(fptr,buf);
xlputc(fptr,'>');
}
/* putclosure - output a closure */
LOCAL void putclosure(fptr,val)
LVAL fptr,val;
{
LVAL name;
if (name = getname(val))
sprintf(buf,"#<Closure-%s: #",getstring(getpname(name)));
else
strcpy(buf,"#<Closure: #");
xlputstr(fptr,buf);
sprintf(buf,AFMT,val); xlputstr(fptr,buf);
xlputc(fptr,'>');
/*
xlputstr(fptr,"\nName: "); xlprint(fptr,getname(val),TRUE);
xlputstr(fptr,"\nType: "); xlprint(fptr,gettype(val),TRUE);
xlputstr(fptr,"\nLambda: "); xlprint(fptr,getlambda(val),TRUE);
xlputstr(fptr,"\nArgs: "); xlprint(fptr,getargs(val),TRUE);
xlputstr(fptr,"\nOargs: "); xlprint(fptr,getoargs(val),TRUE);
xlputstr(fptr,"\nRest: "); xlprint(fptr,getrest(val),TRUE);
xlputstr(fptr,"\nKargs: "); xlprint(fptr,getkargs(val),TRUE);
xlputstr(fptr,"\nAargs: "); xlprint(fptr,getaargs(val),TRUE);
xlputstr(fptr,"\nBody: "); xlprint(fptr,getbody(val),TRUE);
xlputstr(fptr,"\nEnv: "); xlprint(fptr,getenv(val),TRUE);
xlputstr(fptr,"\nFenv: "); xlprint(fptr,getfenv(val),TRUE);
*/
}
/* putfixnum - output a fixnum */
LOCAL void putfixnum(fptr,n)
LVAL fptr; FIXTYPE n;
{
unsigned char *fmt;
LVAL val;
fmt = ((val = getvalue(s_ifmt)) && stringp(val) ? getstring(val)
: (unsigned char *)IFMT);
sprintf(buf,fmt,n);
xlputstr(fptr,buf);
}
/* putflonum - output a flonum */
LOCAL void putflonum(fptr,n)
LVAL fptr; FLOTYPE n;
{
unsigned char *fmt;
LVAL val;
fmt = ((val = getvalue(s_ffmt)) && stringp(val) ? getstring(val)
: (unsigned char *)"%g");
sprintf(buf,fmt,n);
xlputstr(fptr,buf);
}
/* putchcode - output a character */
LOCAL void putchcode(fptr,ch,escflag)
LVAL fptr; int ch,escflag;
{
if (escflag) {
switch (ch) {
case '\n':
xlputstr(fptr,"#\\Newline");
break;
case ' ':
xlputstr(fptr,"#\\Space");
break;
#ifdef MACINTOSH /* lines added by Luke Tierney, March 12, 1988 */
case 0x12: xlputstr(fptr, "#\\Check"); break;
case 0x14: xlputstr(fptr, "#\\Apple"); break;
#endif MACINTOSH /* lines added by Luke Tierney, March 12, 1988 */
default:
sprintf(buf,"#\\%c",ch);
xlputstr(fptr,buf);
break;
}
}
else
xlputc(fptr,ch);
}
/* putoct - output an octal byte value */
LOCAL void putoct(fptr,n)
LVAL fptr; int n;
{
sprintf(buf,"%03o",n);
xlputstr(fptr,buf);
}